perm filename HOMER.F4[MSS,LCS]6 blob
sn#127305 filedate 1974-10-30 generic text, type T, neo UTF8
00100 C***** SUBR. HOMER, FUNC, FINDIT, PLACE,IABS,DRWNT,DATA*****
00200
00300 C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
00400 SUBROUTINE HOMER
00500 IMPLICIT INTEGER(A-Q,S-Z)
00600 REAL PWDS,DISX,A,B,PLACE,STFF
00700 COMMON /STF/RSTFAC(8),RSTJC
00800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20) /POSI/STFF(8),JJB,POS
00900 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
01000 EQUIVALENCE (RJC,RJQ(1)),(RJF,RJQ(4)),(JK,JQ(9)),(RD,RN(4000))
01100 1,(RJG,RJQ(5)),(RJI,RJQ(7)),(RJK,RJQ(9)),(RJM,RJQ(11))
01200 1,(JJ,JQ(8)),(RJH,RJQ(6))
01300 IF(JA.EQ.9)GO TO 9
01400 IF(RJM.NE.0)GO TO 10
01500 C FOR GENL HOMING; WORDS; BEAMS; STEMS;
01600
01700 IF(JQ(1).EQ.0)GO TO 197
01800 C TO HOME IN ON NOTE ON DIFFERENT STAFF.
01900 JJB=RJB
02000 K=PWDS(JJB)
02100 L=PWDS(JQ(1))
02200 RA=RN(K+2)
02300 RB=RN(L+2)
02310 C RB=POS OF NOTE, RA=POS(P2) OF BEAM
02400 N=0
02500 IF(RN(L+5).LT.20)N=-1
02600 C -1 MEANS STEM IS UP
02610 RG=-(AMOD(RN(K+7),10.)-1.)*11./7.
02620 C SPACE FOR THE NUMB. OF BEAMS
02700 JK=RN(L+3)+4.
02800 M=0
02900 IF(RN(K+7).LT.20.)M=-1
03000 X=RN(K+3)+4.
03100 C THE STAFF NUMS. X=BEAM JK=NOTE
03110 RJC=RSTFAC(X)
03115 RJI=RSTFAC(JK)/RJC
03120 RJH=RJC*14.54/5.96
03125 C RJH=WIDTH OF NOTE
03127 C******* 5/74 BOTH STAVES MUST BE SAME SIZE - MOST LIKELY ********
03130 RJG=96./7.
03135 C MUST BE DOUBLE STEM LENGTH
03140 RD=RN(L+8)
03150 IF(RD.EQ.999)RD=0
03160 C THE STEM LENGTH
03200 CC2 JD=6
03300 CC JJ=5
03400 CC IF(RA+3.GE.RB)GO TO 3
03500 CC JD=6
03600 CC JJ=5
03700 3 IF(M.NE.N)GO TO 5
03800 RJH=0
03900 RJG=0
03950 RG=0
04000 GO TO 4
04100 5 IF(M.EQ.0)GO TO 4
04200 RJG=-RJG
04300 RJH=-RJH
04310 RD=-RD
04320 RG=-RG
04400
04450 C NOT OK IF DIFF SIZES AND RA.GT.RB ****** 5/74
04500 4 RN(K+6)=RB+RJH
04600 C SETS CORRECT HORIZANTAL PARAM OF BEAM.
05600 RF=7.*RJI
05700 RE=(STFF(JK)-STFF(X))/RF
05800 C DIST BETWEEN STAVES.
06100 RN(K+5)=RN(L+4)+RE+(RJG+RD+RG)*RJI
06200 RETURN
06300
06400 C*********************************************************
06500 C NEXT ADJUSTS STEMS WHEN BEAMS ARE USED.
06600 197 JJB=-1
06700 DO 191 K=1,ITEM
06800 L=PWDS(K)
06900 IF(RN(L+1).NE.9..OR.(RN(L+3).NE.RJB.AND.RJB.LT.5.))GO TO 191
07000 C TYPE 19 99 FOR ALL STAVES
07100 RG=RN(L+7)
07200 IF(RN(L).EQ.8..OR.RG.LT.10.)GO TO 191
07300 C FINDS BEAMS.
07400 A=RN(L+2)
07500 B=RN(L+6)
07600 C POS 1 AND 2
07700 DISX=B-A
07800 C DISTANCE IN REAL STEPS
07900 RB=AMOD(RN(L+5),100.0)
08000 C NOTE 2
08100 RF=AMOD(RN(L+4),100.0)
08200 RD=RB-RF
08300 C HEIGHT
08400 RJC=RN(L+3)
08500 X=RG/10.
08600 C STEM DIRECT.
08700
08800 DO 192 N=1,ITEM
08900 CC L=PWDS(N)
09000 IF(FINDIT(N))GO TO 192
09100 IF(RN(L).EQ.8)GO TO 192
09200 C SKIPS SLASHED GRACE NOTES
09300 C FINDIT IS NEG. IF(RN(L+1).NE.1.OR.RN(L+3))
09400 RC=RN(L+2)
09500 IF(RC.LT.A.OR.RC.GT.B)GO TO 192
09600 C WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
09700 IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
09800 RC=RC-A
09900 193 RE=AMOD(RN(L+4),100.0)
10000 RC=RD*RC/DISX+RF
10100 RG=RN(L+7)
10200 RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
10300 C DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
10400 C FRACTIONAL NOTE #
10500 195 RA=RC-RE
10600 IF(X.EQ.2)RA=-RA
10700 IF(RA.EQ.0)RA=999.
10800 196 RN(L+8)=RA
10900 C FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
11000 IF(JJB)JJB=N
11100 C SAVES # OF FIRST ITEM FOUND
11200 192 CONTINUE
11300 191 CONTINUE
11400 RETURN
11500
11600 C*********************************************************
11700 9 IF(JK.LT.0)RETURN
11800 C IF P11=-1 NO HOMING
11900 X=RJG/10.
12000 C X IS STEM DIRECTION
12100 RA=RJI
12200 C RJI= POS3
12300 RC=-1.
12400 IF(RJI.NE.0)RC=-2.
12500 IF(JJ/100.EQ.3)RC=-3
12600 C RC=1 ESCAPES FROM LOOP.
12700 C HOMING RANGE FOR BEAMS
12800 10 IF(RJK.EQ.0)RJK=2.9
12900 C IF P11.NE.0 RANGE IS CHANGED FROM 2
13000 IF(JA.EQ.8)RC=-1
13100 CC RE=1.15
13200 CC A=0
13300 CC B=0
13400 DO 361 K=1,ITEM
13500 IF(FINDIT(K))GO TO 361
13600 C SKIPS NOTES ON WRONG LINE
13700 RD=RN(L+2)
13800 CC IF(JA.NE.8)GO TO 1
13900 CC RF=RE*RSTJC
14000 CC IF(RJM.LT.2)GO TO 2
14100 C IF P13=2 SLUR "HOMES" BETWEEN NOTES
14200 CC RE=3.4
14300 CC RF=-.9
14400 CC IF(RN(L+6))RE=3.7
14500 C FOR WHITE NOTES
14600 CC IF(RN(L+7).GE.10)RE=5.8
14700 C FOR DOTTED NOTES
14800 CC2 IF(A.NE.0.OR.PLACE(RJB))GO TO 3
14900 CC A=RD+RE*RSTJC
15000 C PLACES BOTH ENDS OF A SLUR
15100 CC RJB=A
15200 CC3 IF(B.NE.0.OR.PLACE(RJF))GO TO 4
15300 CC B=RD+RF
15400 CC RJF=B
15500 CC4 IF((A.EQ.0.OR.B.EQ.0).AND.K.LT.ITEM)GO TO 361
15600 CC RETURN
15700 1 IF(JA.EQ.9.AND.IFIX(RN(L+5)/10).NE.X)GO TO 361
15800 IF(PLACE(RJB))GO TO 461
15900 RJB=RD
16000 C LOOKS FOR NOTE, STAFF #, STEM DIR.
16100 IF(JA.EQ.9.OR.JA.EQ.8)GO TO 261
16200 RETURN
16300
16400 461 IF(JA.NE.9.AND.JA.NE.8)GO TO 361
16500 IF(PLACE(RJF))GO TO 561
16600 RJF=RD
16700 GO TO 261
16800 561 IF(PLACE(RA))GO TO 661
16900 RJI=RD
17000 GO TO 261
17100 661 IF(JA.EQ.8.OR.JJ.LT.300)GO TO 361
17200 IF(PLACE(RJH))GO TO 361
17300 C HOMES INNER PARTIAL BEAMS
17400 RJH=RD
17500 261 RC=RC+1
17600 IF(RC.EQ.1.)RETURN
17700 361 CONTINUE
17800 END
17900
18000 FUNCTION PLACE(X)
18100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
18200 EQUIVALENCE (RJK,RJQ(9)),(RD,RN(4000))
18300 PLACE=RJK-ABS(RD-X)
18400 END
18500
18600 FUNCTION FINDIT(N)
18700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
18800 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
18900 FINDIT=0
19000 L=PWDS(N)
19100 IF(RN(L+1).NE.1.OR.RN(L+3).NE.RJQ(1))FINDIT=-1
19200 END
19300
19400 FUNCTION IABS(N)
19500 C BECAUSE IABS IN LIB40 HAS A BUG.
19600 IABS=N
19700 IF(N)IABS=-N
19800 END
19900
20000 BLOCK DATA
20100 IMPLICIT INTEGER(A-Q,S-Z)
20300 COMMON /NU/NUMQ(44),RNUMS(327),RACCI(22),NACCI(3)
20400 DATA
20800 1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
20900 1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
21000 1,250,256,261,266, 271,282,285,293,298,307,316,321/
21100 DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
21200 1 104.015, 107.01,107.102, 104.107, 3.107,
21300 1 14.0, 1107.011, 103.015, 103.107, 22.0,
21400 1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
21500 1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
21600 1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
21700 1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
21800 1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
21900 1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
22000 1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
22100 1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
22200 1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
22300 1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
22400 1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
22500 1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
22600 1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
22700 1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
22800 1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
22900 C THE NEXT IS FOR 'F' TO 'P'
23000 C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
23100 DATA (RNUMS(K),K=132,199)/
23200 1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
23300 1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
23400 1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
23500 1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1106.107, 0.107,
23600 1 1103.107, 103.015, 1106.015, 0.015,
23700 1 170.0, 1110.102, 110.105, 108.107, 103.107, 101.105, 101.015,
23800 1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
23900 1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 1.004,
24000 1 8.015, 8.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
24100 1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
24200 C 'Q' TO ')'
24300 DATA(RNUMS(K),K=200,327)/
24400 1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
24500 1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
24600 1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
24700 1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
24800 1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
24900 1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
25000 1 1106.015, 0.107, 6.015, 255.0, 1106.015, 103.107, 1.005, 5.107,
25100 1 8.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
25200 1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
25300 1 281.0, 1101.102, 101.105, 1.105, .102, .105, 101.102, 1.102,
25400 1 1.108, 102.112, 1102.112, 284., 1106.004, 6.004, 292., 1101.102,
25500 1 101.105, 0.102, 0.105, 1.102, 1.105, 101.102, 297.0, 1106.008,
25600 1 6.008, 1106.001, 6.001, 306.0, 1003.015, 1.013, 101.010,
25700 1 102.006,102.002,101.102,1.105, 3.107, 315.0, 1103.015,101.013,
25800 1 1.010, 2.006, 2.002, 1.102, 101.105, 103.107, 320.0, 1106.004,
25900 1 6.004, 1000.01, 0.102, 327.0,1106.004, 6.004, 1003.009,
26000 1 103.101, 1003.101, 103.009/
26100 C 3RD ITEM IN 19400 NOT NEEDED 12/73
26200
26300 C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
26400 DATA RACCI/6.0,1115.003, 110.007, 106.001,
26500 1 115.109, 115.021, 15.0, 1104.104, 118.108,
26600 1 1108.113, 108.016, 1104.008, 118.004,
26700 1 1114.014, 114.115, 22.0,1106.117, 106.007, 114.004
26800 1, 1114.018, 114.107, 106.104/
26900 1 ,NACCI/1,7,16/
27000 END
27100
27200 SUBROUTINE DRWNT(RMINI)
27300 COMMON /STF/RSTFAC(8),RSTJC
27400 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
27900 EQUIVALENCE (JE,JQ(3)),(RJD,RJQ(2)),(RJF,RJQ(4)),
28000 1 (JG,JQ(5)),(RJG,RJQ(5)),(RJE,RJQ(3)),(RJZ,RJQ(20))
28050 1 ,(JI,JQ(7)),(RJI,RJQ(7)),(JH,JQ(6))
28100 RJX=CENTR
28175 JH=0
28187 C JH=0 SO IT WILL FILL. (P8 IN 'CLEFS')
28200 CC CENTR=CENTR-21.*RSTJC
28700 RA=RJF
28800 RJF=.5*RMINI/RSTJC
28900 RJG=RJF
29025 RJD=RJZ-3
29030 CCXX IF(RSTJC.NE.RMINI)RJD=RJZ+.43*(RJZ-3.)-.3
29040 C ADJUSTS POSITION FOR MINI ACCIDENTALS (..??!!)
29050 JI=0
29100 CALL CLEFS
29162 JI=RJI
29168 C ↑↑↑↑↑↑ NEEDED??
29175 C FIX THIS???? ↑↑↑↑↑
29200 C FOR WHITE NOTES AND ACCIS ON PLOTTER.
29300 CENTR=RJX
29400 RJF=RA
29500 RJG=JG
29700 JE=RJE
29800 END